perm filename CGOL.VLI[VLI,LSP] blob
sn#409516 filedate 1978-09-08 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00006 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 READ-TABLES and INITIALISATIONS
C00008 00003 CGOL-KERNEL
C00012 00004 AUXILIAIRES
C00014 00005 NUDS-LEDS of CGOL-KERNEL
C00020 00006 NUDS-LEDS of CGOL-defined-LANGUAGE
C00034 ENDMK
C⊗;
; READ-TABLES and INITIALISATIONS ;
(pour pretty (status 2 17) (status 19 "←"))
(pour index (status 2 17) (status 19 "←"))
(status 19 "←") ; pour neutraliser le mchar "←" i.e. (stop) ;
(status 2 17) ; pour ne plus reconnaitre les chaines ;
; a enlever quand on pourra faire DMC sur "<char>" ;
;------------------------------------------------------------;
(de cgol ()
(cgollex)
(de toplevel ()
(terpri 2)
(escape err
(while t
(setq it (eval (cgolread)))
(if (neq it 'lisp) (print it)
(lisplex) (remprop 'toplevel 'expr)
(reset))))
(print 'skipping 'to '/$)
(while (neq (advance) '/$))))
;--------------------------------------------------------------------;
(de lisplex ()
(mapc oldlex (lambda (char)
(status 19 (car char)) ; char n'est plus 1 mchar ;
(status 17 (car char) (cadr char))
; restitue l'old read-table-val ;
(status 18 (car char) (caddr char))))
; restitue l'old machr-def ;
; ainsi on retablit l'ordre ancien ... ;
(status 15 '/;) ; old commentaire ;
(status 14 '//) ; old / ;
(status 11 '/?) ; old prompt in toplevel ;
(status 12 '/=) ; old prompt out in toplevel ;
(status 1 17) ; pour reconnaitre les chaines a nouveau ;
(status 19 (ascii 27)) ; on tue la def. de mchar pour <ESC> ;
(status 17 (ascii 27) 0) ; et il redevient separateur d'enregistrs. ;
(setq oldlex nil))
;-------------------------------------------------------------------;
(de cgollex ()
(status 15 '/%) ; nouvo commentaire ;
(status 14 '/?) ; nouveau / ;
(status 11 '/<) ; nouvo prompt IN toplevel ;
(status 12 '/>) ; nouvo prompt OUT toplevel ;
(status 2 17) ; pour ne plus reconnaitre les chaines ;
(mapc cgolglyphs
(lambda (char)
(newl oldlex [char (status 17 char) (status 18 char)])
; oldlex = ( ... (char old-read-val old-mach-def) ...) ;
(status 17 char 2)
; file a char la read-val d'un caractere normal ;
(or (eq char '/.)
(eval (subst char 'x '(dmc x () 'x))))))
(status 17 (ascii 27) 2) ; le caractere <ESC> est a present naurmal ;
(status 18 (ascii 27) (lambda () '$))
; il agira comme le daulare ;
(dmc ! () (prog2 (lisplex) (read) (cgollex)))
(dmc /" () (cgol-d-q-macro))
(dmc $ () '$)
(dmc : () (if (neq '/= (peekch)) '/: (readch) '/←))
; i.e. "←" syn ":=" ;
)
;-----------------------------------------------------------------------;
(setq cgolglyphs '(
! /" # $ % & /' /( /) = - @ /[ /] // : * /; /|
+ /. < > /← /↑ /, /\
))
(df defden (l) (apply 'putden l))
; format des appels: ;
; (defden NUD <nom> nil <appel-de-nud-de-nom>) ;
; (defden LED " <valence> " ) ;
(de putden (dentype fun lb code)
(put fun code dentype)
(and lb (put fun lb 'lbp))
fun)
; INITIALISATIONS GLOBALES ;
(put '/$ -1 'lbp)
(setq dbp 0)
(setq silence -1)
(setq defbp 25)
(setq oldlex nil)
; CGOL-KERNEL ;
(de cgolread () (if (eq (advance) '/$) (cgolread) (cgollex) (parse -1)))
(de advance () (setq stringnud nil token (read))
(or (status 4 11) (prin1 token)) ; pour impr. les fics. in en INPUT ;
token)
(de literaltoken () (or (numbp token) stringnud))
(de verify (den) (ifn den nil (advance) den))
(de nuderr () (prog1 ['quote token] (advance)))
(de nuderr () ; traite fonctions et variables inconnues ;
; CGOL connait TOUTES les fonctions VLISP standard 1-aires ;
(if (and (get token 'lbp) (not (memq (typefn token) '(subr fsubr))))
(prog2 (moan [token . '(missing preceding expression)] 2)
(err))
(let ((op token))
(advance)
['quote (if (and (memq (typefn op) '(subr fsubr))
(or (literaltoken) (memq token '(+ -))
(null (get token 'led))))
; bug repare de original CGOL ;
; les SUBR-1 ne pouvaient avoir un nb<0 ;
; comme arg !!!. puisque "-" i.e. le-token ;
; possede une LED, i.e. peut avoir 1 arg gauche ;
[op (parse 25)]
op)])))
(de lederr () (moan [token . '(is not an operator with a left
argument)]
2)
(err))
(de nud ()
(or (verify (if (literaltoken) (or stringnud token)
(get token 'nud)))
(nuderr)))
(de led ()
(or (verify (ifn (literaltoken) (get token 'led)))
(lederr)))
(de lbp ()
(if (literaltoken) 0
(or (get token 'lbp) dbp)))
(de associate (left)
(if (lt rbp (lbp)) (associate (eval (led)))
left))
(de parse (rbp) (associate (eval (nud))))
(de deffix (dentype isfun fun dlbp drbp)
['defden dentype fun dlbp (progn (advance) (parse 0))])
(de delim d (while d (put (nextl d) 0 'lbp)))
(de isn (fun rb) [fun])
(de iss (fun rb) [fun left])
(de isp (fun rb) [fun (parse rb)])
(de isi (fun rb) [fun left (parse rb)])
(de ism (fun rb cont) [fun left . (parselist rb cont)])
(de check (del)
(if (eq token del) (advance)
(moan ['missing del 'inserted 'before token] 0)))
(de moan (message db)
(if (gt db silence) (apply 'print message)))
; AUXILIAIRES ;
(de getlist (rbp)
(cons (parse rbp)
(if (neq token '/,) nil (advance) (getlist rbp))))
(de getvarlist ()
(if (neq token '/;)
(cons (prog1 token (advance))
(if (neq token '/,) nil (advance) (getvarlist)))))
(de gettokens ()
(ifn (memq token '(/) /] /' /;))
(cons (prog1 token (advance))
(gettokens))))
(df defext (a) (apply 'putext a))
(de putext (fun lb code dentype body args expr)
(if code (putden dentype fun lb code))
(put fun ['lambda args body] expr))
(de cgol-d-q-macro ()
(cadadr (setq stringnud
['quote ['quote
(apply 'gensym
(let ((x (readch)))
(if (neq x /") [x . (self (readch))] )))
]])))
(de parselist (rb cont)
(cons (parse rb)
(if (neq token cont) nil
(advance)
(parselist rb cont))))
; NUDS-LEDS of CGOL-KERNEL ;
; ADVANCE ;
(defden nud advance () '(advance))
; LITERALTOKEN ;
(defden nud literaltoken () '(literaltoken))
; VERIFY ;
(defden nud verify () ['verify (parse 25)])
; NUDERR ;
(defden nud nuderr () '(nuderr))
; LEDERR ;
(defden nud lederr () '(lederr))
; NUD ;
(defden nud nud () '(nud))
; LED ;
(defden nud led () '(led))
; LBP ;
(defden nud lbp () '(lbp))
; ASSOCIATE ;
(defden nud associate () ['associate (parse 25)])
; PARSE ;
(defden nud parse () ['parse (parse 25)])
; RIGHT ;
(defden nud right () ['parse drbp])
; RIGHTLIST ;
(defden nud rightlist () ['getlist drbp])
; NILFIX ;
(defden nud nilfix () (deffix 'nud 'isn token () ()))
; PREFIX ;
(defden nud prefix () (deffix 'nud 'isp token () (advance)))
; SUFFIX ;
(defden nud suffix () (deffix 'led 'iss token (advance) nil))
; INFIX ;
(defden nud infix () (deffix 'led 'isi token (advance) token))
; INFIXR ;
(defden nud infixr ()
(deffix 'led 'isi token (advance) (sub1 token)))
; INFIXD ;
(defden nud infixd ()
(deffix 'led 'isi token (advance) (advance)))
; INFIXM ;
(defden nud infixm ()
(deffix 'led 'ism token (advance) token))
; DELIM ;
(defden nud delim () ['delim (parse 25)])
; IS ;
(defden nud is () [isfun (parse 25) drbp])
; CHECK ;
(defden nud check () ['check (parse 25)])
; NUDS-LEDS of CGOL-defined-LANGUAGE ;
; DELIMITEURS ;
(delim '| 'by 'in 'do 'then 'else '/' '/] '/, '/) 'end 'elsif)
; DENOTATIONS ;
; GETLIST ;
(defden nud getlist () ['getlist (parse 25)])
; GETVARLIST ;
(defden nud getvarlist () '(getvarlist))
; GETTOKENS ;
(defden nud gettokens () '(gettokens))
; MOAN ;
(defden nud moan ()
['moan (prog1 (parse 2) (check 'level)) (parse 2)])
; DEFINE ;
(defden nud define () (nud!define))
(de nud!define (;; fun type args code instr lb rb expr)
(setq expr (if (memq token '(expr fexpr macro))
(prog1 token (advance))
'expr)) ; type par defaut: EXPR ;
(if stringnud
(setq args () type 'nud code ['list]
instr ['prog1 ['quote token]])
(setq args [token])
(advance)
(setq type 'led code ['list ['quote token]]
instr ['prog1 'left]))
(setq fun token)
(advance)
(if (and (eq token '/() (not stringnud))
(progn (advance) (setq args (getvarlist)) (check '/))
(setq code () instr ()))
(while (or (not (memq token '(/; /,))) stringnud)
(while stringnud
(setq instr (append1 instr ['check ['quote token]]))
(delim token)
(advance))
(setq code (append1 code instr))
(if (and (memq token '(/; /,)) (not stringnud))
(setq instr nil)
(setq instr ['prog1 ['parse '#rbp]]
args (append1 args token))
(advance))))
(setq lb (if (eq type 'led)
(if (neq token '/,) defbp
(advance)
(eval (parse 1))))
rb (if (neq token '/,) (or lb defbp)
(advance)
(eval (parse 1)))
code (subst rb '#rbp (append code (if instr [instr]))))
(check '/;)
; un premier patch pour arranger le miserable code ;
; qui sort en son absence ;
; le patch doit transformer dans CODE : ;
; tout (PROG1 x) en x ;
(if (null code) nil
(setq code (mapcar code (lambda (x)
(if (and (listp x) (eq (car x) 'prog1)
(null (cddr x)))
(cadr x)
x))))
(putden type fun lb code))
(if (neq token '/$)
['defext fun lb code type (parse 0) args expr])
)
; DEFEXT ;
(defden nud defext () ['defext (parse 25)])
; ( ;
(defden nud /( nil (prog1 (parse 0) (check '/))))
(defden led /( 30 (prog1
[left . (if (neq token '/)) (getlist 0))]
(check '/))))
; BEGIN ;
(defden nud begin () (prog1 (parse 0) (check 'end)))
(defden led begin 30 (prog1
[left . (if (neq token 'end) (getlist 0))]
(check 'end)))
; [ ;
(defden nud /[ () (prog1
(if (neq token '/]) ['list . (getlist 0)])
(check '/])))
; ' ;
(defden nud /' () (prog1
(isp 'quote 0) (check '/'))))
; # ;
(defden nud /# () (prog1 token (advance)))
; \ le new LAMBDA ;
(defden nud /\ ()
['lambda (prog1 (getvarlist) (check '/;)) (parse 0)])
; NEW ;
(defden nud new ()
['prog (prog1 (getvarlist) (check '/;)) ['return (parse 0)]])
; LITERAL ;
(defden nud literal () ['xliteral . (getlist 1)])
(de xliteral (x) (mapc x (lambda (i) (set i i))))
; le-fameux-point-virgule ;
(defden led /; 1 (ism 'progn 1 '/;))
; /& ;
(defden led /& 1 ['prog1 left (parse 0)])
; IF ;
(defden nud if () (nud!if))
(de nud!if ()
(cons 'cond
(let ()
(cons [(parse 2) (progn (check 'then) (parse 2))]
(selectq token
(else (advance) [[t (parse 2)]])
(elsif (advance) (self))
())))))
; WHILE ;
(defden nud while ()
['while (parse 2) (progn (check 'do) (parse 2))])
; FOR ;
(defden nud for () (nud!for))
(de nud!for (;; var llist body)
(setq var (prog1 (parse 2) (check 'in))
llist (prog1 (parse 2) (check 'do))
body (parse 2))
(if (and (listp llist) (memq (car llist) '(to downto)))
(sublis [['var . var] ['body . body]
['test . (if (eq (car llist) 'to) 'gt 'lt)]
['bi . (c→dr llist)] ['bs . (caddr llist)]
['step . (cadddr llist)]]
'(let ((var bi))
(if (test var bs) nil
body
(self (+ var step)))))
['mapc llist ['lambda [var] body]]))
; TO ;
(defden led to 18 ['to left (parse 18)
(if (neq token 'by) 1 (advance) (parse 18))])
(de to (a b c)
(if (le a b) [a . (to (- c a) b c)]))
; DOWNTO ;
(defden led downto 18 ['downto left (parse 18)
(if (neq token 'by) -1 (advance) (parse 18))])
(de downto (a b c)
(if (ge a b) [a . (downto (+ c a) b c)]))
; LOTSOF ;
(defden led lotsof 1
['repeat left (parse 0)])
; ← FLECHE-GAUCHE: AFFECTATION ;
(defden led /← 25 (led!assign))
(de led!assign () (cond
((atom left) (isi 'setq 1))
; var ← e : (setq var e) ;
((eq (car left) 'car)
['rplaca (cadr left) (parse 1)])
; car e1 ← e2 : (rplaca e1 e2) ;
((eq (car left) 'cdr)
['rplacd (cadr left) (parse 1)])
; cdr e1 ← e2 : (rplacd e1 e2) ;
((eq (car left) 'get) ['put (cadr left) (parse 1) (caddr left)])
; e0 of e1 ← e2 : (put e1 e2 e0) ;
(t (append1 (cons (if (eq 'array (typefn (car left)))
'setqa 'seta)
left)
(parse 1)))))
; tab(e1) ← e2 : (setqa tab e1 e2) ;
; var(e1) ← e2 : (seta var e1 e2) ;
; LET ;
(defden nud let () (nud!let))
(de nud!let (;; lvar lval)
(and (neq token 'in)
(let ((x (parse 2)))
(newl lvar (cadr x)) (newl lval (caddr x))
(if (neq token '/,) nil
(advance) (self (parse 2)))))
(check 'in)
[['lambda (freverse lvar) (parse 2)] . (freverse lval)])
;format: ;
; LET v <:=,←,=> e[,v ← e]* IN body ;
; OF ;
(defden led of 26 ['get (parse 25) left])
; /. ;
(defden led /. 14 (isi 'cons 13))
; EXISTS ;
(defden led exists 10 ['setq 'it left])
; /@ ;
(defden led /@ 14 (isi 'append 13))
; = ;
(defden nud /= () (eval (parse 25)))
(defden led /= 10 (isi 'equal 10))
; NE ;
(defden led ne 10 (isi 'nequal 10))
; EQ ;
(defden led eq 10 (isi 'eq 10))
; NEQ ;
(defden led neq 10 (isi 'neq 10))
; < ;
(defden led < 10 (isi 'lt 10))
; LE ;
(defden led le 10 (isi 'le 10))
; > ;
(defden led > 10 (isi 'gt 10))
; GE ;
(defden led ge 10 (isi 'ge 10))
; ISIN ;
(defden led isin 10 (isi 'member 10))
; AND ;
(defden led and 8 (isi 'and 8))
; OR ;
(defden led or 7 (isi 'or 7))
; | BARRE-VERTICALE: VALEUR ABSOLUE ;
(defden nud | ()
(prog1 (isp 'abs 0) (check '|)))
; + ;
(defden nud + () (parse 20))
(defden led + 20 (isi '+ 20))
; - ;
(defden nud - () (nud!minus))
(de nud!minus () (let ((x (isp 'minus 20)))
(if (numbp (cadr x)) (- 0 (cadr x))
['- 0 x])))
(defden led - 20 (isi '- 20))
; * ;
(defden led * 21 (isi '* 21))
; // en LED ;
(defden led // 21 (isi '// 21))
; MOD en LED ;
(defden led mod 21 (isi 'rem 21))
; ↑ en LED FLECHE VERTICALE: EXPONENTIATION ;
(defden led /↑ 22 (isi '** 22))